perm filename RHYTH.F4[NEW,LCS]21 blob sn#356856 filedate 1978-05-24 generic text, type T, neo UTF8
C***** SUBRS RHYTH, NOTNUM, DOTS  ********  

	SUBROUTINE RHYTH
	COMMON/RINP/R(10,85),POSNT(0/99)
	1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2,
	1 RA,RDD,ITB,POSB /PTR/KWDS(1) /FRMT/FQZ(3),IREAD
	1 /XRN/RN(1) /IDEV/IDEV
	1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
	1 /SCX/JALPHA(30),JX,JXX,JZ,IRHY,JD,KA,KB,IZ
	1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,
	1 NFLG,KXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
	1 /ALF/INP(59),NX,NOTE,JSET,KZ,KX,AVGPOS,RLPOS,RLP2,
	1 AVP2,ZX,RE,ZZ,RD,RSTX
C   SEE ALSO FILLMS, SETLET AND SETUP  RE. /FLM/
	DIMENSION RPOS(2,100)
	COMMON R2,JH,CENTR,J2,R3,R4,R5,RJQ(17),J3,JQ(19)
	1 /DPY/ST(4000),MEDIT,GO /LIMIT/LIMIT,ITEM,NL,NO,NONO
	1 /POS/POS1,POS2 /STF/RSTFAC(0/7),RSTJ2
	EQUIVALENCE (VX(1),X),(VX(2),Y),(VX(7),Z),(RPOS,ST(3400))
	1,(VX(3),AB),(VX(4),T),(VX(5),RB),(VX(6),X2)
	1,(VX(8),C),(VX(9),S),(VX(10),X3)

CCC	DATA FIB/.75/
C  FIB IS FOR PSUEDO-FIBONACCI SPACING
	RSTJ3=RSTFAC(IFIX(STAFF))
	POSNT(0)=-1
	POSNT(1)=-1
C IN CASE 1ST NOTE IS AT POS. ZERO
	NX=-1
	JX=0
	T=0
	Y=0
	NOTE=0
	ICNTPT=-1
	NOSET=0
	JSET=0
C  STUP IS NEG. IF SETUP IS NOT READY
	IF(STUP)GO TO 341
	IF(SET4.NE.STAFF)GO TO 70
	NOSET=-1
C  TO ADD MORE NOTES ON SETUP LINE. WIPES OUT P9 AT END OF SCMSS.
	GO TO 270
70	DO 370 K=1,ITEM-IZ-1
C LOOKS ONLY AT THINGS BEFORE CURRENT INPUT.
	J=KWDS(K)
	IF(RN(J+1).GT.2)GO TO 370
	IF(RN(J+2).EQ.STAFF)GO TO 270
370	CONTINUE
	GO TO 170
270	ICNTPT=0
C THIS WILL CAUSE NOTES ADDED TO LINE TO HAVE NO RHYTH VAL IN P9
170	KZ=1
	POS2=PS2
C  GETS LAST ↑↑ POS. FROM SETUP
	JSET=-1
C  NEXT NUM.(100) IS LIMIT FOR STF.4 (CAN BE UP TO 300-SEE /FLM/)
	DO 9 KX=1,100
9	IF(RPOS(2,KX).GE.0)GO TO 10
10	AVGPOS=RPOS(1,KX)
	RLPOS=AVGPOS
344	KX=KX+1
	IF(RPOS(2,KX).EQ.-3)GO TO 344
C**** IGNORES CLEFS (BUT NOT BARS) IN AUTOMATIC SPACING ***** 10/76
	RLP2=RPOS(1,KX)
343	AVP2=RPOS(2,KX)-.001
	IF(AVP2.GT.0)GO TO 341
	KX=KX+1
	GO TO 343
C  AVERAGED AND REAL POSITIONS FROM 'SETUP'

C  NEXT FOR NON-SETUP
341	DO 34 K=1,IRHY
	CALL DOTS(VAL,RH,K,DOT)
C VAL=RHYTH. VALUE (QTR=1), RH=DENOMINATOR (QTR=4), DOT=NUM OF DOTS
C  88TH NOTES ARE TAKEN AS GRACE NOTES. THEN BECOME 32NDS.
	IF(RH.NE.88)GO TO 345
	IF(JSET)GO TO 34
C  GRACE NOTES SKIPPED IN AUTOMATIC SETUP
	VAL=.1    
CFIB345	IF(STUP.LT.-1)VAL=PFIBX(VAL)
345	IF(STUP.LT.-1)VAL=14.0*EXP(ALOG(VAL)*0.5849624)
C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5))  NOT FIBBONACI (1.618)
CCC345	IF(STUP.LT.-1)Z=Z+(.125-Z)*FIB
C  STUP CAN BE SET TO .LT.-1 IN NOTBMS FOR PSUEDO-FIBONACCI SPACE
	Y=Y+VAL
34	CONTINUE
C  Y=TOTAL TIME
C A SAFEGUARD
C  SAVES POS1 FOR POSITIONING MF, CRESC. ETC.
	NTC=0
C  THE WORD COUNT FOR REAL NOTES.
	IF(JSET)GO TO 3421

	IF(POS1.LT.POS2)POSX=POS1
C  SAVES IT FOR BACKUP
	IF(POS1.GE.POS2)POS1=POSX

	Z=POS2-POS1
	ZX=Z
342	DO 1 K=1,IZ
	X=R(1,K)
	IF(X.LT.3.)GO TO 1
C  JUMP IF NOTE OR REST
	IF(X.NE.17.)GO TO 8
C   JUMP IF NOT A KEY SIG.
	RA=AMOD(R(5,K),100.0)
C  100+KEY SIG NUM  =  SIG MADE UP OF NATURALS.
	RA=2.+ABS(RA)*2.0
	GO TO 6
8	IF(X.NE.4.)GO TO 81
C   NEXT IS FOR BAR LINES
	RA=3
	J=K+1
	RE=R(1,J)
	IF(RE.EQ.3.)RA=1.5
C  A CLEF
	IF(RE.EQ.18)RA=2.5
C  A METER
	IF(RE.NE.1)GO TO 83
	IF(AMOD(R(5,J),10.).NE.0)RA=4.5
C  FINDS ACCI ON NEXT NOTE.
83	IF(K.EQ.IZ)RA=0
C  END OF STAFF
	GO TO 6
82	RA=5
CGHB82	RA=6
	GO TO 83
81	IF(X.EQ.18)GO TO 82
	RA=6.
	IF(K.LT.3)RA=8.
CGHB	RA=7.
C   FOR CLEFS
CGHB	IF(K.LT.3)RA=9.
C   THE FIRST CLEF IS NOT MINI
6	RA=RA*RSTJ3
C  SO SPACE WILL DEPEND ON SIZE OF STAFF
	Z=Z-RA
	R(8,K)=RA
C   STORES SPACE NUM THAT MUST BE GIVEN BACK
1	CONTINUE
C   SUBTRACTS SPACE FOR CLEF OR BAR.  WILL ADD BOTH LATER.
C  POS1 AND Z ARE FOR RHYTHMIC SPACING
C  SPACE FOR NON-NOTES
3421	K=0
	IF(ABS(Y-RA).LE..001)GO TO 3
	IF(JSET)CALL MISMCH(RA,Y)
C TYPES MISMATCH MESSAGE

C   LOOP TO END
3	K=K+1
C   K IS COUNTER
	T=0
CXX	R(7,K)=0
	RE=R(1,K)
	IF(RE.LE.2.)GO TO 2
	RD=R(8,K)
	R(8,K)=0
	IF(JSET)GO TO 71

7	IF(K.EQ.IZ)POS1=POS2
	IF(R(1,K-1).GT.2.)GO TO 73
	IF(K.EQ.1)GO TO 73
	IF(RE.EQ.4.)GO TO 73
	Z=Z+RD/3.
C   RETURNS 1/3 OF THE SPACE IF PREV. ITEM IS NOTE OR REST
	POS1=POS1-RD/3
C  THIS CAN RESULT IN OVERLAP WHICH MUST BE EDITED OUT.!!
73	R(3,K)=POS1
72	POS1=POS1+RD
C   ABOVE SECTION LEAVES ROOM FOR CLEF OR BAR
	GO TO 337

C  40???   50????  WHY NOT 100?
71	DO 74 J=KZ,80
74	IF(RE.EQ.-RPOS(2,J))GO TO 75
	POS=R(3,K-1)+4
	GO TO 76
75	POS=RPOS(1,J)
	KZ=J+1
C  FOUND SAME TYPE OF ITEM.
76	R(3,K)=POS
	GO TO 337

2	JX=JX+1
21	CALL DOTS(VAL,RH,JX,DOT)
	V(JX)=VAL
	IF(RE.NE.2)GO TO 121
	V(JX)=-VAL
C  SHOWS RESTS IN AUTO. BEAM SECTION.(ASSUMES REST WAS A + NUMB.)
	R(7,K)=VAL
	GO TO 210
121	IF(R(8,K).GE.-1.)R(9,K)=VAL
C  STORES RHYTH VALUE FOR LATER USE IN PART EXTRACTOR IF NOT CHORD NOTE.
CCC	IF(AB.GT..05)GO TO 210
	IF(RH.NE.88.)GO TO 210
	R(3,K)=-1.
	R(4,K)=R(4,K)+100.
C  WILL THIS BE OK WITH NOTES BELOW B3 (I.E. NEG POSITIONS.
	R(7,K)=1
C  FOUND A GRACE NOTE  (88TH NOTE)   
	RB=4./88.
	R(9,K)=RB    
	JZ=1
	IF(STEM.GE.0)GO TO 1211
	IF(R(9,K-1).EQ.RB)GO TO 1211
4211	IF(V(JX+1).EQ.88..AND.R(1,K+1).EQ.1)GO TO 1211
C  STEM WILL BE UP UNLESS PRESET OR TWO OR MORE IN A ROW.
	IF(R(5,K).GE.20.)R(5,K)=R(5,K)-10.
C NOW STEM IS UP

1211	IF(R(8,K+JZ).GE.0)GO TO 211
	J=K+JZ
C GRACE NOTE CHORDS
	R(3,J)=-1
C  FOR AUTO-SPACING AT 337
	R(4,J)=R(4,J)+100.
C MAKE IT A MINI-NOTE
	R(8,K)=1000.+ABS(R(4,K)-R(4,J))
C  EXTEND THE STEM
	JZ=JZ+1
C  FOR MORE CHORD NOTES.  SHOULD I CHECK FOR END (IZ)?
	GO TO 1211
C  ** NOT NOW ***TURNS STEM OVER. UNLESS STEM DIRECTIONS WERE FIXED.(SU/SD/)
211	IF(JZ.LE.1)R(8,K)=1000
2211	IF(JSET.GE.0)GO TO 3211
	K=K+JZ-1
C  POS WILL BE SET AT 336
	NTC=NTC+1
C  UPDATE THE COUNTER FOR IMPORTANT POSITIONS. POSNT SET AT 336
	POSNT(NTC)=-1
	GO TO 337
3211	VAL=.1    
C IT USED TO JUMP.  NOW MAKES SPACE FOR GRACE NOTES AS 32NDS.
210	RB=0
C  FOR AUTOMATIC SETUP
	JZ=K
C  JZ WILL BE USED NEAR END
CC3634	IF(AMOD(AB,.1875).EQ.0)GO TO 122
CC	T=IDOT*10
C IDOT IS NUM OF DOTS
	IF(RE.EQ.2.)GO TO 35
	IF(RH.EQ.88)GO TO 22
CXX	T=0
	IF(RH.LT.8)GO TO 522
CC	IF(R(5,K).LT.10)GO TO 422
C DON'T ADD TAILS TO STEMLESS NOTE. (IT CONFUSES 'BEAMS')
	T=IFIX(ALOG(RH)/0.6931472+.001)-2.0
C RH=8=1 TAIL,  16=2TAILS, ETC. THE NUM. (8,16) IS RESULT OF 2 TO THE NTH.
522	RB=0
	IF(DOT.EQ.0)GO TO 422
	IF(R(6,K).GE.20)RB=100 
C  TO SHIFT DOT DOWN 2 STEPS
422	R(7,K)=T+RB+DOT
	T=0
cc422	R(7,K)=T+IDOT
C  PUTS ONE OR MORE DOTS
CC	GO TO 36
	GO TO 22

35	IF(R(6,K).GE.0)GO TO 135
	R(6,K)=-1
	GO TO 22
C  ADDS DOT TO REST. (IF R6 IS -2. = INVIS. REST. CHANGE IT TO -1)
135	R(6,K)=DOT/10.
CC35	R(6,K)=T/10.
CC36	RB=VAL/3.
CC	IF(T.NE.1)RB=(4*VAL)/7
C  TO KEEP TAIL ON DOTTED NOTE

22	POS=POS1
	IF(R(6,K).GE.30)R(6,K)=R(6,K)-30
C  30 NEEDED FOR SOME CASES WITH DOTS ON CHORDS.
	IF(JSET.EQ.0)GO TO 220

C  NEXT IS FOR SETUP
222	IF(NOTE)GO TO 223
C  FIRST TIME A NOTE IS FOUND.
	NOTE=-1
	POS1=RLPOS
	Z=POS2-POS1
C  RESETS SPACE AVAILABLE, ZZ IS SPACE FOR NON-NOTES
223	IF(POS1.LT.AVP2)GO TO 221
224	KX=KX+1
C???? OCT, 73	 	IF(NX.EQ.0)GO TO 225
	L=KX
1228	IF(RPOS(2,L).NE.-3)GO TO 228
	L=L+1
C  IGNORE CLEFS (BUT NOT BARS) ********* 10/76
	GO TO 1228
228	IF(NX)RLP2=RPOS(1,L)
	NX=-1
225	IF(RPOS(2,KX-1))GO TO 227
	RLPOS=RPOS(1,KX-1)
	AVGPOS=AVP2
227	AVP2=RPOS(2,KX)-.001
	IF(AVP2.GT.0)GO TO 223
C  0 IN RPOS=POS. OF NON-NOTE
CC****** WHY NEEDED?? 6/74 ***	IF(RLP2.GE.POS1)NX=0
	NX=0
CC*****↑↑↑↑ CHANGED FROM ABOVE ***  6/74
	GO TO 224
221	POS=(POS1-AVGPOS)*(RLP2-RLPOS)/(AVP2-AVGPOS)+RLPOS
220	R(3,K)=POS
4634	IF(RE.NE.1)GO TO 44
	IF(POS.EQ.POSNT(NTC))GO TO 2634
C  SKIPS OTHER CHORD NOTES.
	NTC=NTC+1
	POSNT(NTC)=POS
C  SAVES IT FOR NUMBS ABOVE NOTES, ETC.
2634	IF(RH.LT.4)GO TO 4
C JUMP IF DENOM. IS LESS THAN 4.  I.E. 1/2 NOTE ETC.
44	L=K+1
	IF(R(8,L).GE.0)GO TO 1634
	IF(R(1,L).NE.1.)GO TO 1634
C   JUMP IF NOT DOUBLE STOP
C  DELETES STEM FROM WHOLE NOTE CHORD (NOW DONE IN NOTWRT IF P7=1)
	R(3,L)=R(3,K)
	K=L
CC	R(8,K)=0
	GO TO 522 
C  LOOPS BACK TO PICK UP MORE CHORD NOTES

C 'WHITENS' HALF, WHOLE AND TRIPLET HALF NOTES.
4	RA=-R(6,K)
	IF(RA.EQ.0)RA=-1
	IF(RH.GE.2.)GO TO 144
	R(5,K)=AMOD(R(5,K),10.0)
C  TAKES STEM INFO OFF ANYTHING LONGER THAN 1/2 NOTES -- FOR SLUR ROUTINE.
	RP=1
	IF(RH.LE..5)RP=2
	R(7,K)=R(7,K)+RP
C  +1=WHOLE NOTE WILL PRINT  +2=DBL WHL NT.
CC NOT NEEDED BECAUSE OF ABOVE. 	RA=-2.
144	R(6,K)=RA
	GO TO 44

1634	T=POS1
	RP=VAL
CFIB	IF(STUP.LT.-1)RP=PFIBX(VAL)
	IF(STUP.LT.-1)RP=14.0*EXP(ALOG(RP)*0.5849624)
C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5))  NOT FIBBONACI (1.618)
CCC	IF(STUP.LT.-1)RP=AB+(.125-AB)*FIB
C  FOR PSUEDO-FIB. SPACING
	POS1=RP/Y*Z+POS1
535	IF(R(1,JZ).EQ.1.)GO TO 337
	RA=R(4,JZ)
C  SETS REST
	IF(R(8,JZ).NE.0.1)GO TO 537
	T=-4
	R(8,JZ)=-2
C  -2 CENTERS THE SIGN UNDER THE RIGHT CONDITIONS
	GO TO 536
CC537	IF(VAL.LT.2)GO TO 538
CC	T=-1
CC	IF(RH.LT.2)T=-2
CC	IF(RH.LT.1)T=-3
C  -1=HLF RST, -2=WHOLE, -3=DBL WHL RST, -4=REPEAT BAR SIGN(./.)
CC	GO TO 536
537	T=IFIX(ALOG(RH)/0.6931472+.001)-2.
536	R(5,JZ)=T
CCC	GO TO 337
C*******  4/74  NEW WAY TO FIND TAILS
C  OMITS RESTS  (REALLY???)
CCC334	R(7,JZ)=T+R(7,JZ)
337	IF(K.LT.IZ)GO TO 3
	M=NTC+1
C********* WAS M=NTC ******* 4/14/78
	DO 335 K=IZ,1,-1
	IF(R(3,K).GE.0)GO TO 335
	IF(K.NE.IZ)GO TO 336
	R(3,K)=POS2-4.
	GO TO 335
336	N=K-1
1336	RA=R(3,N)
	IF(RA.GT.0)GO TO 2336
	N=N-1
	IF(N.GT.0)GO TO 1336
C GO BACK (IF MORE GRACE NOTES.) TO FIND PREVIOUS BIG NOTE.
2336	T=R(3,K+1)
	RB=T-RA
	RA=3
	IF(RB.LE.4)RA=RB/2.
C IF SPACE IS SMALL USE 1/3 OF IT.
	RB=T-RA
C NEXT FOR GRACE NOTE CHORDS
	IF(R(8,K+1).GE.0)GO TO 1335
	RB=T
CC	RB=R(3,K+1)
	M=M+1
1335	R(3,K)=RB
	POSNT(M)=RB
335	M=M-1
	K=0
45	K=K+1
C  NEXT IS TO ARRANGE DOTS.
	IF(R(7,K).LT.10)GO TO 451
	RA=R(3,K)
	DO 452 M=K+1,IZ
	IF(R(3,M).NE.RA)GO TO 453
C  JUMP IF NOT CHORD NOTE.
	T=R(7,M)
	RB=R(4,M)
	IF(T.LT.100.)GO TO 452
C  JUMP IF NOTE IS NOT ON LEFT SIDE OF UPWARD STEM
	IF(RB-R(4,M-1).NE.2)GO TO 452
	IF(AMOD(RB,2.).NE.0)R(7,M)=AMOD(T,10.)
C  TAKES AWAY DOT IN CERTAIN CASES TO AVOID CONFUSION.
452	CONTINUE
453	K=M-1
451	IF(K.LT.IZ)GO TO 45

	IF(ICNTPT)GO TO 13
	DO 113 K=1,IZ 
	RA=R(1,K)
	IF(RA.GT.2)GO TO 113
C THIS ZEROS RHYTH PARAM IF NOTES WERE ALREADY ON THIS LINE.
	J=9
	IF(RA.EQ.2)J=7
	R(J,K)=0
113	CONTINUE
13	N=IZ
	NTC=NTC+1
	POSNT(NTC)=200
	POSNT(0)=0
	IF(IREAD.GE.0.AND.IDEV.EQ.5)CALL NOTNUM
	END

	SUBROUTINE NOTNUM
CC	DIMENSION ISU(390)
	COMMON R2,JH,CENTR,J2,R3,R4,R5,RJQ(17),J3,J4,J5,JQ(17)
	1 /RINP/R(10,85),POSNT(0/99)
	1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2
	1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
	1 /POSI/STFF(0/7),JJ2,POSQ /DPY/ST(4000),MEDIT,GO
	CALL DPYSET(3,ST(3600),390)
	CALL DPYBRT(6)
	J2=STAFF
	POSQ=STFF(J2)
	J5=1
	R4=20
C  R5=0=1  STANDARD SIZE IS USED.
	DO 131 K=1,NTC-1
	R3=RHORZ(POSNT(K))
	CALL PNUM
C  GOES TO DRAW A NUMBER OVER A NOTE
	J5=J5+1
	IF(J5.EQ.10)J5=0
131	CONTINUE
132	CALL DPYOUT(3)
	CALL SETPOG(1)
	END

	SUBROUTINE DOTS(VAL,RH,K,DOT)
	COMMON/SCM/V(1)
C FINDS DOTS (1000S), GET RHYTH. AND RHYTHMIC VALUE (QTR=1)
	RH=V(K)
	IF(RH.EQ.0)RH=88.
	VAL=4/RH
	J=RH/1000.
	DOT=J*10
	IF(J.EQ.0)RETURN 
	RH=RH-J*1000
	VAL=4./RH
	Z=VAL
1	Z=Z/2
	VAL=VAL+Z
	J=J-1
	IF(J.GT.0)GO TO 1
	END